home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / AlphaBits.tcl next >
Encoding:
Text File  |  2000-10-31  |  5.5 KB  |  193 lines
  1. if {[catch {
  2.     # First fix some problems with Tcl 7.4
  3.     if {[info tclversion] < 7.6} { 
  4.     set tcl_platform(platform) macintosh
  5.     # Alpha already has these two renamed internally
  6.     # they need their argument packaged as a list!
  7.     ;proc mkdir {dir} {
  8.         oldMkdir [list $dir]
  9.     }
  10.     ;proc rmdir {dir} {
  11.         oldRmdir [list $dir]
  12.     }
  13.     if {[info commands __file] == ""} {
  14.         rename file __file
  15.         ;proc file {cmd args} {
  16.         switch -- $cmd {
  17.             "join" {
  18.             regsub -all "::" [join $args ":"] ":" res
  19.             return $res
  20.             }
  21.             "copy" {eval copyFile $args}
  22.             "rename" {
  23.             if {[catch {eval moveFile $args} err]} {
  24.                 if {$err == "An unknown error occured."} {
  25.                 # Buggy Alpha moveFile, try our best so move
  26.                 # the file anyway.  This will lose the resource
  27.                 # fork.
  28.                 set f_to [lindex $args 1]
  29.                 set f_from [lindex $args 0]
  30.                 if {[file exists $f_from] && [file isfile $f_from]} {
  31.                     set contents [file::readAll $f_from]
  32.                     file::writeAll $f_to $contents 1
  33.                     removeFile $f_from
  34.                     return
  35.                 }
  36.                 return -code error "Sorry, moveFile has a\
  37.                   bug.  Please contact the Alpha-D mailing\
  38.                   list for help."
  39.                 } else {
  40.                 return -code error $err
  41.                 }
  42.             }
  43.             }
  44.             "delete" {
  45.             set i 0 
  46.             while 1 {
  47.                 switch -- [lindex $args $i] {
  48.                 "-force" {
  49.                     incr i
  50.                     set force 1
  51.                 }
  52.                 "--" {
  53.                     incr i
  54.                     break
  55.                 }
  56.                 default {
  57.                     break
  58.                 }
  59.                 }
  60.             }
  61.             global file::separator
  62.             foreach f [lrange $args $i end] {
  63.                  if {[file isdirectory $f]} {
  64.                 if {[info exists force]} {
  65.                     rm -r [string trimright $f ${file::separator}]
  66.                 } else {
  67.                     rmdir $f
  68.                 }
  69.                  } else {
  70.                 removeFile $f
  71.                  }
  72.             }
  73.             }
  74.             "mkdir" {eval mkdir $args}
  75.             "volumes" {
  76.             # Thanks to Jon
  77.             return [tclAE::build::resultData 'MACS' core getd ---- {obj {form:indx, want:type(cdis), seld:abso('all '), from:'null'()}} rtyp TEXT] 
  78.             }
  79.             "split" {
  80.             return [split [lindex $args 0] :]
  81.             }
  82.             "attributes" {
  83.             switch -- [lindex $args 1] {
  84.                 "-readonly" {
  85.                 #__file stat [lindex $args 0] r
  86.                 if {[llength $args] > 2} {
  87.                     # set read-only status
  88.                 } else {
  89.                     # get read-only status
  90.                     return [expr {![__file writable [lindex $args 0]]}]
  91.                 }
  92.                 }
  93.                 default {
  94.                 error "file attributes [lindex $args 1] unimplemented"
  95.                 }
  96.             }
  97.             
  98.             }
  99.             "nativename" {
  100.             return [lindex $args 0]
  101.             }
  102.             "pathtype" {
  103.             # Not a perfect implementation, but not bad.
  104.             global alpha::noMenusYet
  105.             # We do this nasty hack to avoid loading all the
  106.             # AE code when we rebuild tcl indices on an Alpha
  107.             # upgrade.  Frankly I don't think anyone's ever
  108.             # used a relative path with Alpha except when
  109.             # they type 'auto_mkindex .' in the shell.
  110.             if {[info exists alpha::noMenusYet] && ${alpha::noMenusYet}} {
  111.                 return "absolute"
  112.             }
  113.             set relative 1
  114.             set path [lindex $args 0]
  115.             foreach volume [file volumes] {
  116.                 if {[string first $volume $path] == 0} {
  117.                 unset relative
  118.                 break
  119.                 }
  120.             }
  121.             if {[info exists relative]} {
  122.                 return "relative"
  123.             } else {
  124.                 return "absolute"
  125.             }
  126.             }
  127.             default {uplevel 1 __file $cmd $args}
  128.         }
  129.         }
  130.     }
  131.     } 
  132.     # Startup of Alpha/Alphatk is split into two phases. The first
  133.     # phase initialises the environment (PREFS folder, early prefs, etc),
  134.     # and the second phase continues with loading of packages, menus,
  135.     # etc, and reads in all of the user's ordinary preferences.  During
  136.     # the first phase we should avoid interacting with the user, because
  137.     # the gui may not yet be properly created.
  138.     # 
  139.     # We split things into two phases so that, for example, the editor
  140.     # can use some of the information gathered in the first phase
  141.     # (especially the early prefs) and use them to control what happens
  142.     # later.  For example, the location/type of status bar used can be
  143.     # set from such early preferences.
  144.     
  145.     # First phase:
  146.     # basic initialisation: (works with Alpha 7.2.1 or 8.0 development)
  147.     # (Note that this phase has already happened under Alphatk, and possibly
  148.     # in the future under Alpha 8).
  149.     source [file join $HOME Tcl SystemCode initAlphaTcl.tcl]
  150.  
  151.     # Second phase:
  152.     # do all the more complex stuff:
  153.     source [file join $HOME Tcl SystemCode runAlphaTcl.tcl]
  154.  
  155. } err]} {
  156.     append alpha::errorLog "\r" $errorInfo
  157.     set errCache $errorInfo
  158.     if {![llength [info commands auto_load]] \
  159.       || (![auto_load dialog::yesno] || ![auto_load dialog::alert])} {
  160.     # This error happened either too early on in a weird way,
  161.     # so that even the auto-loading mechanism doesn't work
  162.     # (and has overwritten the original problem)
  163.     # We just use the cached information.
  164.     set errorInfo $errCache
  165.     alertnote "That was a core startup error.  Alpha will probably\
  166.       not function correctly.  Press Ok to view the error.  Also note\
  167.       that auto-loading seems not to be functioning."
  168.     if {[info tclversion] < 8.0} {
  169.         alertnote [string range $errorInfo 0 250]
  170.     } else {
  171.         alertnote $errorInfo
  172.     }
  173.     } else {
  174.     if {[dialog::yesno -y "View the error" -n "Continue" \
  175.       "That was a core startup error.  Alpha will probably\
  176.       not function correctly."]} {
  177.         dialog::alert $errCache
  178.     }
  179.     }
  180. }
  181. if {[info exists alpha::errorLog]} {
  182.     catch {
  183.     new -n "* Alpha startup error log *" -info ${alpha::errorLog}
  184.     unset alpha::errorLog
  185.     }
  186. }
  187. # call these two procs to sort out the menu enabled state.
  188. catch {
  189.     menuEnableHook [expr {[win::Current] != ""}]
  190.     requireOpenWindowsHook 2
  191. }
  192. message "Initialization Complete"
  193.